The 640 MEG Shareware Studio 2/The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO/door/twview93.zip/VIEWDOS.INC

Text File | 1992-03-11 | 15KB | 511 lines

{VIEWDOS.INC}

const
  xmax = 470;
  ymax = 270;
  XDimMax  = 20;
  YDimMax  = 15;
  xoffset  = 10;
  yoffset  = -2;

type
  Vertex = record
             sectorNum: integer;  { 0 if not in use }
           end;
  XIndex = 1..XDimMax;
  YIndex = 1..YDimMax;
  Screen = array [XIndex, YIndex ] of Vertex;
  Pair   = record
             visible : boolean;
             row : XIndex;
             col : YIndex;
           end;
  SectorToScreen = array [ sector ] of pair;


procedure View;
var
  Grid      : screen;
  OnScreen  : SectorToScreen;
  XMax      : integer;
  XDim      : XIndex;
  XLength   : integer;
  YMax      : integer;
  YDim      : YIndex;
  YLength   : integer;
  abort,
  GotDistances : boolean;
  BaseSector: sector;

{$I svga.inc }

function xpixel( i,j : integer ) : integer;
begin
  if not odd( j ) then
    xpixel := (2 * i - 1) * XLength
  else
    xpixel := 2 * i * XLength;
end;

function ypixel( i,j : integer ) : integer;
begin
  ypixel := (2 * j - 1) * Ylength;
end;

procedure Tag( var STS : sectorToScreen;
               var scr : screen;
                   num : sector;
                  irow : XIndex;
                  jcol : YIndex );
{ put sector num into screen scr at irow, jcol; update sts accordingly }
begin
  if sts[ num].visible then
    writeln('sector ', num, ' already placed before Tag!')
  else if scr[ irow, jcol ].sectorNum <> 0 then
    writeln('row ', irow, ', col ', jcol, ' already in use!')
  else
    begin
      with STS[ num ] do
        begin
          visible := true;
          row     := irow;
          col     := jcol;
        end; {with}
      scr[ irow, jcol ].SectorNum := num;
    end; {else}
end; {tag}

procedure CheckOffspring( var P : Queue; where : sector; maxDist : integer);
{ Check all sectors from "where" to see if they should be pushed
onto the Queue }
var
  t : warpIndex;
begin
  with space.sectors[ where ] do
    if number > 0 then
      for t := 1 to number do
        if (not OnScreen[ data[ t ] ].visible) and
           (Distances[ data[t] ].d <= maxDist)    then
          enqueue( P, where, data[ t ] );
end; {check offspring}

procedure GoDirection( d : integer;
                   var Row   : XIndex;
                   var Col   : YIndex);
{ 0 is upleft, 1 left, 2 downleft, 3 downright, etc mod 6 }
begin
  d := abs( d ) mod 6;
  if odd( Col ) then
    case d of
      0 : begin
            if Col > 1 then col := col - 1;
            if Row < XDim then row := row + 1;
          end;
      1 : if Row < XDim then row := row + 1;
      2 : begin
            if Col < YDim then col := col + 1;
            if Row < XDim then row := row + 1;
          end;
      3 : if Col < YDim then col := col + 1;
      4 : if row > 1 then row := row - 1;
      5 : if Col > 1 then col := col - 1;
    end {case}
  else
    case d of
    0 : if Col > 1 then col := col - 1;
    1 : if Row < XDim then row := row + 1;
    2 : if Col < YDim then col := col + 1;
    3 : begin
          if Col < YDim then col := col + 1;
          if Row > 1 then row := row - 1;
        end;
    4 : if Row > 1 then row := row - 1;
    5 : begin
          if Col > 1 then col := col - 1;
          if Row > 1 then row := row - 1;
        end;
    end; {case}
end;

procedure seek( var freerow : Xindex; var freecol : Yindex; home : sector );
const
  MaxTries = 100;
var
  one, two, three, n : integer;
{ Trying to find a home for the new guy, close to the home sector.
one, two, and three will be random directions to try (of radius 1, 2, and
3).  When we are successful, we just break out of the procedure, hopefully
returning a freerow and freecol. }
begin
  one := random( 6 );
  for one := one to one + 5 do { from random start, advance 5 positions }
    begin
      freerow := OnScreen[ home ].row;
      freecol := OnScreen[ home ].col;
      GoDirection( one, freerow, freecol );
      if grid[ freerow, freecol ].SectorNum = 0 then
        exit;
    end; {one}
  one := random( 6 );
  two := random( 6 );
  for one := one to one + 5 do
    for two := two to two + 5 do
      begin
        freerow := OnScreen[ home ].row;
        freecol := OnScreen[ home ].col;
        GoDirection( one, freerow, freecol );
        GoDirection( two, freerow, freecol );
        if grid[ freerow, freecol ].SectorNum = 0 then
          exit;
      end; {one two}
  one := random( 6 );
  two := random( 6 );
  three := random( 6 );
  for one := one to one + 5 do
    for two := two to two + 5 do
      for three := three to three + 5 do
        begin
          freerow := OnScreen[ home ].row;
          freecol := OnScreen[ home ].col;
          GoDirection( one, freerow, freecol );
          GoDirection( two, freerow, freecol );
          GoDirection( three, freerow, freecol );
          if grid[ freerow, freecol ].SectorNum = 0 then
            exit;
        end; {one two three}
  writeln('couldn''t place anything near ', home );
  n := 0;
  repeat
    freerow := random( xdim ) + 1;
    freecol := random( ydim ) + 1;
    n := n + 1;
  until (n = MaxTries) or (grid[ freerow, freecol ].sectorNum = 0);
end; {seek}

procedure FindHome( var Grid : screen;
                    var Showing : SectorToScreen;
                        home, near : sector );
{ This is an interesting bit: given the home sector, find an open slot
in the Grid to place the near sector. }
var
  basedir : integer;
  baserow : XIndex;
  basecol : YIndex;
begin
{  writeln('Trying to find a home for ', near, ' close to ', home );
  writeln('starting at ', showing[ home ].row, showing[ home ].col ); }
  seek( baserow, basecol, home );
  if grid[ baserow, basecol ].SectorNum <> 0 then
    writeln('Seek Failed!')
  else
    Tag( Showing, Grid, near, baserow, basecol );
{  writeln('chose ', baserow, ' ', basecol );
  readln; }
end;

procedure DistanceSortedQueueLoad( var q : queue; max : integer );
{ Load all pairs (parent, offspring) from the distance array whose distance
is less than max, but do so in priority order sorted by distance. }
var
  r : integer;
  sec : sector;
begin
  for r := 1 to max do
    for sec := 1 to maxSector do
      if distances[sec].d = r then
        enqueue( q, distances[sec].s, sec );
end; {DistanceSortedQueueLoad}

procedure PlaceSectors( var Grid  : screen;
                        var Showing : SectorToScreen;
                        var maxDist : integer;
                        var BaseSect : sector );
var
  PlaceMe : Queue;
  daddy, sonny : sector;
begin
  Tag( showing, Grid, baseSect, XDim div 2, YDim div 2 ); { put first in center}
  PlaceMe.front := 0;
  DistanceSortedQueueLoad( PlaceMe, maxdist );
  While PlaceMe.front <> 0 do
    begin
      serve( PlaceMe, daddy, sonny );
      if showing[ daddy ].visible then
        FindHome( Grid, Showing, daddy, sonny );
    end; {while}
end; {while}

procedure InitSectorToScreen( var s : SectorToScreen );
var
  n : sector;
begin
  for n := 1 to MaxSector do
    s[ n ].visible := false;
end;

procedure InitScreen( var s : Screen );
var
  r : XIndex;
  c : YIndex;
begin
  for r := 1 to XDim do for c := 1 to YDim do
    s[ r, c ].sectorNum := 0;
end;


procedure FillGrid( var Grid : screen;
                    var Showing : SectorToScreen;
                    var Distances : distanceArray;
                    var HaveDists : boolean;
                    var sn : sector;
                    var abort : boolean );
{ Choose a sector, and fill Distances with distance to that sector,
as well as Showing and Grid based on nearby vertices. }
var
  maxD : integer;
  ch   : char;
begin
  InitSectorToScreen( Showing );
  InitScreen( Grid );
  if not HaveDists then
    begin
      repeat
        write('Starting at which sector? ');
        readln( sn );
        if sn = 0 then
          begin
            writeln('Aborting...');
            abort := true;
            exit;
          end; {if}
        if space.sectors[ sn ].number = 0 then
          writeln('You have never visited ', sn );
      until space.sectors[ sn ].number > 0;
      write( 'Sectors <L>eaving ', sn, ', sectors coming <T>oward ', sn, ', or <B>oth? ');
      readln( ch );
      if ch in ['l','L'] then
        TwoWayDistances( sn, distances, false, true )
      else if ch in ['t','T'] then
        TwoWayDistances( sn, distances, true, false )
      else
        TwoWayDistances( sn, distances, true, true );
      HaveDists := true;
    end; {if}
  write( 'Max distance to include? ');
  readln( maxD );
  writeln( 'Total of ', CountDist(Distances, maxD), ' at distance at most ', MaxD );
  PlaceSectors( Grid, Showing, maxD, sn );
end; {FillGrid}

function PortColor( g : stuff; mono : boolean ) : word;
begin
  if (GetMaxColor = 1) or mono then
    PortColor := 0
  else
    case g of
      NotAPort : PortColor := Black;
             0 : PortColor := Blue;
             1 : PortColor := Green;
             2 : PortColor := Cyan;
             3 : PortColor := LightRed;
             4 : PortColor := Magenta;
             5 : PortColor := LightBlue;
             6 : PortColor := LightGreen;
             7 : PortColor := LightCyan;
             8 : PortColor := Yellow;
      else
        PortColor := black;    {shouldn't happen...}
    end; {case}
end; {PortColor}

function  SectorColor( s : sector; mono : boolean ) : word;
begin
  if GetMaxColor = 1 then {monochrome}
    SectorColor := 1
  else  {not monochrome }
    with space.sectors[s] do
      if number = 0 then
        if mono then
          SectorColor := White
        else
          SectorColor := Yellow
      else if etc and HasFighters <> 0 then
        SectorColor := White
      else if porttype = NotAPort then
        SectorColor := LightGray
      else if PortColor( porttype, mono ) < LightBlue then
        SectorColor := LightGray
      else
        SectorColor := black;
end; {SectorColor}

procedure CircleSector( x : XIndex; y : YIndex; s : sector; mono : boolean );
var
  r, c, xradius : integer;
  xasp, yasp    : word;
  ColorUsed     : word;
  Pporttype     : string;
begin
  r := xpixel( x, y );
  c := ypixel( x, y );
  GetAspectRatio( xasp, yasp );
  xradius := round( yasp/xasp * ylength/2);
  SetLineStyle( SolidLn, 0, NormWidth );
  if space.sectors[s].number = 0 then
    SetColor( Black )
  else
    SetColor( SectorColor( s , mono) );
  SetFillStyle( SolidFill, PortColor( space.sectors[s].porttype, mono ) );
  if space.sectors[s].porttype = NotAPort then
    FillEllipse( r, c, xradius, ylength div 2 )
  else
    begin
      bar( r - xradius, c - ylength div 2, r + xradius, c + ylength div 2 );
      rectangle( r - xradius, c - ylength div 2,
                 r + xradius, c + ylength div 2 );
    end; {port}
  if space.sectors[s].number = 1 then
    circle( r, c, xradius + 3 );
  SetColor( SectorColor( s, mono) );
  if (not mono) or (space.sectors[s].porttype = NotAPort) then
    outTextXY( r, c, str( s, 3 ) )
  else {use mono display}
    begin
      outtextXY(r, c-3, str(s,3));
      outtextXY(r, c+7, status(space.sectors[s].porttype) );
    end; {else}
  if space.sectors[s].etc and SpaceLane <> Nothing then
    begin
      SetLineStyle( SolidLn, 0, NormWidth );
      MoveTo( r - xradius,  c - ylength div 2 );
      LineTo( r + xradius, c + ylength div 2 );
    end; {if}
end;

procedure ConnectVertices( i1, i2 : XIndex; j1, j2 : YIndex;
                           TwoWay : boolean );
var
  n,
  x1, y1, x2, y2 : integer;
  dist : real;
begin
  x1 := xpixel( i1, j1 );
  y1 := ypixel( i1, j1 );
  x2 := xpixel( i2, j2 );
  y2 := ypixel( i2, j2 );
  if TwoWay then
    SetLineStyle( SolidLn, 0, NormWidth )
  else
    SetLineStyle( DashedLn, 0, ThickWidth );
  dist := sqrt( abs(i2-i1) + abs(j2-j1));
  if (dist <= 1.5) or (dist >=9) then
    n := 0
  else
    n := round(3*dist);

  MoveTo( x1+n, y1+n );
  LineTo( x2+n, y2+n );
end;

procedure DrawGrid( var G : screen; STS : SectorToScreen );
var
  i : XIndex;
  j : YIndex;
  t : WarpIndex;
  temp : integer;
begin
  for i := 1 to XDim do
    for j := 1 to YDim do
      if G[ i, j ].sectorNum <> 0 then
        with G[ i, j ] do
          with space.sectors[ sectorNum ] do if number > 0 then
            for t := 1 to number do
              if STS[ data[ t ] ].visible then
                ConnectVertices( i, STS[data[t] ].row, j, STS[data[t]].col,
                                 IsWarp( data[t], sectorNum ) );
  for i := 1 to XDim do
    for j := 1 to YDim do
      if G[ i, j ].sectorNum <> 0 then
          CircleSector( i, j, G[i,j].sectorNum, mono );
end;

{$I initgrph.inc }

procedure GetDimensions( var x : XIndex; var xl : integer;
                         var y : YIndex; var yl : integer );
const
  whitespace : set of char = [' ', #9, #10, #13 ];
var
  line : string;
  ok   : boolean;
  tempx, tempy,
  position : integer;
begin
  ok := false;
  repeat
    write('Max dimensions? [', XDimMax, ' by ', YDimMax, ']  ');
    readln( line );
    if line = '' then
      begin
        ok := true;
        x := XDimMax * 2 div 3;
        y := YDimMax * 2 div 3;
      end
    else
      begin
        position := 1;
        tempx := 0;
        while (position <= length( line )) and
              (line[position] in ['0'..'9']) do
          begin
            tempx := 10 * tempx + ord( line[ position ] ) - ord( '0' );
            inc( position );
          end; {while}
        inc( position );
        while (position <= length( line ) ) and
              (line[position] in whitespace) do
          inc( position );
        tempy := 0;
        while (position <= length( line )) and
              (line[position] in ['0'..'9']) do
          begin
            tempy := 10 * tempy + ord( line[position] ) - ord('0');
            inc( position );
          end; {while}
        ok := (tempx>0) and (tempx<=XDimMax) and (tempy>0) and (tempy<=YDimMax);
        if ok then
          begin
            x := tempx;
            y := tempy;
          end {if}
        else
          begin
            writeln('I don''t understand ', line );
            writeln('Please give two integers separated by a space.');
          end; {else}
      end; {else}
  until ok;
  InitGraphics;
  XMax := GetMaxX;
  YMax := GetMaxY;
  closeGraph;
  xl := trunc( XMax / x / 2 );
  yl := trunc( YMax / y / 2);
end;

begin {view}
    GetDimensions( XDim, XLength, YDim, Ylength );
    GotDistances := false;
    abort := false;
    repeat
      FillGrid( Grid, OnScreen, Distances, GotDistances, BaseSector, abort );
      if not abort then
        begin
          InitGraphics;
          DrawGrid( Grid, Onscreen );
          readln;
          closeGraph;
          abort := not prompt( 'again? ');
        end; {not abort}
    until abort;
end; {view}